home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / psgml / psgml-edit.el.z / psgml-edit.el
Encoding:
Text File  |  1998-05-21  |  55.6 KB  |  1,718 lines
  1. ;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support
  2. ;;-*-byte-compile-warnings:(free-vars unused-vars unresolved callargs redefine)-*-
  3. ;; $Id: psgml-edit.el,v 2.25 1996/03/31 21:30:22 lenst Exp $
  4.  
  5. ;; Copyright (C) 1994, 1995, 1996 Lennart Staflin
  6.  
  7. ;; Author: Lennart Staflin <lenst@lysator.liu.se>
  8.  
  9. ;; This program is free software; you can redistribute it and/or
  10. ;; modify it under the terms of the GNU General Public License
  11. ;; as published by the Free Software Foundation; either version 2
  12. ;; of the License, or (at your option) any later version.
  13. ;; 
  14. ;; This program is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18. ;; 
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with this program; if not, write to the Free Software
  21. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23.  
  24. ;;;; Commentary:
  25.  
  26. ;; Part of major mode for editing the SGML document-markup language.
  27.  
  28.  
  29. ;;;; Code:
  30.  
  31. (provide 'psgml-edit)
  32. (require 'psgml)
  33. (require 'psgml-parse)
  34. (require 'tempo)
  35.  
  36.  
  37. ;;;; Variables
  38.  
  39. (defvar sgml-split-level nil
  40.   "Used by sgml-split-element")
  41.  
  42.  
  43. ;;;; SGML mode: structure editing
  44.  
  45. (defun sgml-last-element ()
  46.   "Return the element where last command left point.
  47. This either uses the save value in `sgml-last-element' or parses the buffer
  48. to find current open element."
  49.   (setq sgml-markup-type nil)
  50.   (if (and (memq last-command sgml-users-of-last-element)
  51.        sgml-last-element)        ; Don't return nil
  52.       sgml-last-element
  53.     (setq sgml-last-element (sgml-find-context-of (point))))  )
  54.  
  55. (defun sgml-set-last-element (&optional el)
  56.   (if el (setq sgml-last-element el))
  57.   (sgml-show-context sgml-last-element))
  58.  
  59. (defun sgml-beginning-of-element ()
  60.   "Move to after the start-tag of the current element.
  61. If the start-tag is implied, move to the start of the element."
  62.   (interactive)
  63.   (goto-char (sgml-element-stag-end (sgml-last-element)))
  64.   (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
  65.                  (sgml-element-parent sgml-last-element))))
  66.  
  67. (defun sgml-end-of-element ()
  68.   "Move to before the end-tag of the current element."
  69.   (interactive)
  70.   (goto-char (sgml-element-etag-start (sgml-last-element)))
  71.   (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
  72.                  (sgml-element-parent sgml-last-element))))
  73.  
  74. (defun sgml-backward-up-element ()
  75.   "Move backward out of this element level.
  76. That is move to before the start-tag or where a start-tag is implied."
  77.   (interactive)
  78.   (goto-char (sgml-element-start (sgml-last-element)))
  79.   (sgml-set-last-element (sgml-element-parent sgml-last-element)))
  80.  
  81. (defun sgml-up-element ()
  82.   "Move forward out of this element level.
  83. That is move to after the end-tag or where an end-tag is implied."
  84.   (interactive)
  85.   (goto-char (sgml-element-end (sgml-last-element)))
  86.   (sgml-set-last-element (sgml-element-parent sgml-last-element)))
  87.  
  88. (defun sgml-forward-element ()
  89.   "Move forward over next element."
  90.   (interactive)
  91.   (let ((next
  92.      (sgml-find-element-after (point) (sgml-last-element))))
  93.     (goto-char (sgml-element-end next))
  94.     (sgml-set-last-element (sgml-element-parent next))))
  95.  
  96. (defun sgml-backward-element ()
  97.   "Move backward over previous element at this level.
  98. With implied tags this is ambigous."
  99.   (interactive)
  100.   (let ((prev                ; previous element
  101.      (sgml-find-previous-element (point) (sgml-last-element))))
  102.     (goto-char (sgml-element-start prev))
  103.     (sgml-set-last-element (sgml-element-parent prev))))
  104.  
  105. (defun sgml-down-element ()
  106.   "Move forward and down one level in the element structure."
  107.   (interactive)
  108.   (let ((to
  109.      (sgml-find-element-after (point) (sgml-last-element))))
  110.     (when (sgml-strict-epos-p (sgml-element-stag-epos to))
  111.       (error "Sub-element in other entity"))
  112.     (goto-char (sgml-element-stag-end to))
  113.     (sgml-set-last-element (if (sgml-element-empty to)
  114.                    (sgml-element-parent to)
  115.                  to))))
  116.  
  117.  
  118. (defun sgml-kill-element ()
  119.   "Kill the element following the cursor."
  120.   (interactive "*")
  121.   (sgml-parse-to-here)
  122.   (when sgml-markup-type
  123.     (error "Point is inside markup"))
  124.   (kill-region (point)
  125.            (sgml-element-end (sgml-find-element-after (point)))))
  126.  
  127. (defun sgml-transpose-element ()
  128.   "Interchange element before point with element after point, leave point after."
  129.   (interactive "*")
  130.   (let ((pre (sgml-find-previous-element (point)))
  131.     (next (sgml-find-element-after (point)))
  132.     s1 s2 m2)
  133.     (goto-char (sgml-element-start next))
  134.     (setq m2 (point-marker))
  135.     (setq s2 (buffer-substring (point)
  136.                    (sgml-element-end next)))
  137.     (delete-region (point) (sgml-element-end next))
  138.     (goto-char (sgml-element-start pre))
  139.     (setq s1 (buffer-substring (point) (sgml-element-end pre)))
  140.     (delete-region (point) (sgml-element-end pre))
  141.     (insert-before-markers s2)
  142.     (goto-char m2)
  143.     (insert s1)
  144.     (sgml-message "")))
  145.  
  146. (defun sgml-mark-element ()
  147.   "Set mark after next element."
  148.   (interactive)
  149.   (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t))
  150.  
  151. (defun sgml-mark-current-element ()
  152.   "Set mark at end of current element, and leave point before current element."
  153.   (interactive)
  154.   (let ((el (sgml-find-element-of (point))))
  155.     (goto-char (sgml-element-start el))
  156.     (push-mark (sgml-element-end el) nil t)))
  157.  
  158.  
  159. (defun sgml-change-element-name (gi)
  160.   "Replace the name of the current element with a new name.
  161. Eventual attributes of the current element will be translated if 
  162. possible."
  163.   (interactive
  164.    (list (let ((el (sgml-find-element-of (point))))
  165.        (goto-char (sgml-element-start el))
  166.        (sgml-read-element-name
  167.         (format "Change %s to: " (sgml-element-name el))))))
  168.   (when (or (null gi) (equal gi ""))
  169.     (error "Illegal name"))
  170.   (let* ((element (sgml-find-element-of (point)))
  171.      (attspec (sgml-element-attribute-specification-list element))
  172.      (oldattlist (sgml-element-attlist element)))
  173.     (unless (sgml-element-empty element)
  174.       (goto-char (sgml-element-end element))
  175.       (delete-char (- (sgml-element-etag-len element)))
  176.       (tempo-process-and-insert-string (sgml-end-tag-of gi)))
  177.     (goto-char (sgml-element-start element))
  178.     (delete-char (sgml-element-stag-len element))
  179.     (tempo-process-and-insert-string (sgml-start-tag-of gi))
  180.     (forward-char -1)
  181.     (let* ((newel (sgml-find-element-of (point)))
  182.        (newattlist (sgml-element-attlist newel))
  183.        (newasl (sgml-translate-attribute-specification-list
  184.             attspec oldattlist newattlist)))
  185.       (sgml-insert-attributes newasl newattlist))))
  186.  
  187. (defun sgml-translate-attribute-specification-list (values from to)
  188.   "Translate attribute specification from one element type to another.
  189. Input attribute values in VALUES using attlist FROM is translated into
  190. a list using attlist TO."
  191.   (let ((new-values nil)
  192.     (sgml-show-warnings t)
  193.     tem)
  194.     (loop for attspec in values 
  195.       as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from)
  196.       as to-decl   = (sgml-lookup-attdecl (sgml-attspec-name attspec) to)
  197.       do
  198.       (cond
  199.        ;; Special case ID attribute
  200.        ((and (eq 'id (sgml-attdecl-declared-value from-decl))
  201.          (setq tem (sgml-attribute-with-declared-value to 'id)))
  202.         (push
  203.          (sgml-make-attspec (sgml-attdecl-name tem)
  204.                 (sgml-attspec-attval attspec))
  205.          new-values))
  206.        ;; Use attribute with same name if compatible type
  207.        ((equal (sgml-attdecl-declared-value from-decl)
  208.            (sgml-attdecl-declared-value to-decl))
  209.         (push attspec new-values))
  210.        (to-decl
  211.         (sgml-log-warning
  212.          "Attribute %s has new declared-value"
  213.          (sgml-attspec-name attspec))
  214.         (push attspec new-values))
  215.        (t
  216.         (sgml-log-warning "Can't translate attribute %s = %s"
  217.                   (sgml-attspec-name attspec)
  218.                   (sgml-attspec-attval attspec)))))
  219.     new-values))
  220.  
  221. (defun sgml-untag-element ()
  222.   "Remove tags from current element."
  223.   (interactive "*")
  224.   (let ((el (sgml-find-element-of (point))))
  225.     (when (or (sgml-strict-epos-p (sgml-element-stag-epos el))
  226.           (sgml-strict-epos-p (sgml-element-etag-epos el)))
  227.       (error "Current element has some tag inside an entity reference"))
  228.     (goto-char (sgml-element-etag-start el))
  229.     (delete-char (sgml-element-etag-len el))
  230.     (goto-char (sgml-element-start el))
  231.     (delete-char (sgml-element-stag-len el))))
  232.  
  233. (defun sgml-kill-markup ()
  234.   "Kill next tag, markup declaration or process instruction."
  235.   (interactive "*")
  236.   (let ((start (point)))
  237.     (sgml-with-parser-syntax
  238.      (sgml-parse-s)
  239.      (setq sgml-markup-start (point))
  240.      (cond ((sgml-parse-markup-declaration 'ignore))
  241.        ((sgml-parse-processing-instruction))
  242.        ((sgml-skip-tag)))
  243.      (kill-region start (point)))))
  244.  
  245.  
  246. ;;;; SGML mode: folding
  247.  
  248. (defun sgml-fold-region (beg end &optional unhide)
  249.   "Hide (or if prefixarg unhide) region.
  250. If called from a program first two arguments are start and end of
  251. region. And optional third argument true unhides."
  252.   (interactive "r\nP")
  253.   (let ((mp (buffer-modified-p))
  254.     (inhibit-read-only t)        ;
  255.     (buffer-read-only nil)        ; should not need this, but
  256.                     ; perhaps some old version of
  257.                     ; emacs does not understand
  258.                     ; inhibit-read-only
  259.     (before-change-function nil)
  260.     (after-change-function nil))
  261.     (setq selective-display t)
  262.     (unwind-protect
  263.     (subst-char-in-region beg end
  264.                   (if unhide ?\r ?\n)
  265.                   (if unhide ?\n ?\r)
  266.                   'noundo)
  267.       (when sgml-buggy-subst-char-in-region
  268.     (set-buffer-modified-p mp)))))
  269.  
  270. (defun sgml-fold-element ()
  271.   "Fold the lines comprising the current element, leaving the first line visible.
  272. This uses the selective display feature."
  273.   (interactive)
  274.   (sgml-parse-to-here)
  275.   (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
  276.           sgml-markup-type)
  277.      (sgml-fold-region sgml-markup-start
  278.                (save-excursion
  279.                  (sgml-parse-to (point))
  280.                  (point))))
  281.     ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
  282.           (looking-at " *<!"))
  283.      (sgml-fold-region (point)
  284.                (save-excursion
  285.                  (skip-chars-forward " \t")
  286.                  (sgml-parse-to (1+ (point)))
  287.                  (point))))
  288.  
  289.     (t
  290.      (let ((el (sgml-find-element-of (point))))
  291.        (when (eq el sgml-top-tree)
  292.          (error "No element here"))
  293.        (save-excursion
  294.          (goto-char (sgml-element-end el))
  295.          (when (zerop (sgml-element-etag-len el))
  296.            (skip-chars-backward " \t\n"))
  297.          (sgml-fold-region (sgml-element-start el)
  298.                    (point)))))))
  299.  
  300. (defun sgml-fold-subelement ()
  301.   "Fold all elements current elements content, leaving the first lines visible.
  302. This uses the selective display feature."
  303.   (interactive)
  304.   (let* ((el (sgml-find-element-of (point)))
  305.      (c (sgml-element-content el)))
  306.     (while c
  307.       (sgml-fold-region (sgml-element-start c)
  308.             (sgml-element-end c))
  309.       (setq c (sgml-element-next c)))))
  310.  
  311. (defun sgml-unfold-line ()
  312.   "Show hidden lines in current line."
  313.   (interactive)
  314.   (let ((op (point)))
  315.     (beginning-of-line)
  316.     (push-mark)
  317.     (end-of-line)
  318.     (exchange-point-and-mark)
  319.     (sgml-fold-region (point) (mark) 'unhide)
  320.     (goto-char op)))
  321.  
  322. (defun sgml-unfold-element ()
  323.   "Show all hidden lines in current element."
  324.   (interactive)
  325.   (let* ((element (sgml-find-element-of (point))))
  326.     (sgml-fold-region (sgml-element-start element)
  327.               (sgml-element-end element)
  328.               'unfold)))
  329.  
  330. (defun sgml-expand-element ()
  331.   "As sgml-fold-subelement, but unfold first."
  332.   (interactive)
  333.   (sgml-unfold-element)
  334.   (sgml-fold-subelement))
  335.  
  336. (defun sgml-unfold-all ()
  337.   "Show all hidden lines in buffer."
  338.   (interactive)
  339.   (sgml-fold-region (point-min)
  340.             (point-max)
  341.             'unfold))
  342.  
  343. ;;;; SGML mode: indentation and movement
  344.  
  345. (defun sgml-indent-line (&optional col element)
  346.   "Indent line, calling parser to determine level unless COL or ELEMENT
  347. is given.  If COL is given it should be the column to indent to.  If
  348. ELEMENT is given it should be a parse tree node, from which the level
  349. is determined."
  350.   (when sgml-indent-step
  351.     (let ((here (point-marker)))
  352.       (back-to-indentation)
  353.       (unless (or col element)
  354.     ;; Determine element
  355.     (setq element
  356.           (let ((sgml-throw-on-error 'parse-error))
  357.         (catch sgml-throw-on-error
  358.           (if (eobp)
  359.               (sgml-find-context-of (point))
  360.             (sgml-find-element-of (point)))))))
  361.       (when (eq element sgml-top-tree)    ; not in a element at all
  362.     (setq element nil)        ; forget element
  363.     (goto-char here))        ; insert normal tab insted)
  364.       (when element
  365.     (sgml-with-parser-syntax
  366.      (let ((stag (sgml-is-start-tag))
  367.            (etag (sgml-is-end-tag)))
  368.        ;; Wing change
  369.        (when (and
  370.           (not (member* (sgml-element-gi
  371.                  (if (or stag etag)
  372.                      (sgml-element-parent element)
  373.                    element))
  374.                 sgml-inhibit-indent-tags
  375.                 :test #'equalp))
  376.           (or sgml-indent-data
  377.               (not (sgml-element-data-p
  378.                 (if stag
  379.                 (sgml-element-parent element)
  380.                   element)))))
  381.          (setq col
  382.            (* sgml-indent-step
  383.               (+ (if (or stag etag) -1 0)
  384.              (sgml-element-level element))))))))
  385.       (when (and col (/= col (current-column)))
  386.     (beginning-of-line 1)    
  387.     (delete-horizontal-space)
  388.     (indent-to col))
  389.       (when (< (point) here)
  390.     (goto-char here))
  391.       col)))
  392.  
  393. (defun sgml-next-data-field ()
  394.   "Move forward to next point where data is allowed."
  395.   (interactive)
  396.   (when (eobp)
  397.     (error "End of buffer"))
  398.   (let ((sgml-throw-on-warning 'next-data)
  399.     (avoid-el (sgml-last-element)))
  400.     ;; Avoid stopping in current element, unless point is in the start
  401.     ;; tag of the element
  402.     (when (< (point) (sgml-element-stag-end avoid-el))
  403.       (setq avoid-el nil))
  404.     (catch sgml-throw-on-warning
  405.       (while (progn
  406.            (sgml-parse-to (1+ (point)))
  407.            (setq sgml-last-element
  408.              (if (not (eq ?< (following-char)))
  409.              (sgml-find-element-of (point))
  410.                sgml-current-tree))
  411.            (or (eq sgml-last-element avoid-el)
  412.            (not (sgml-element-data-p sgml-last-element)))))
  413.       (sgml-set-last-element))))
  414.  
  415. (defun sgml-next-trouble-spot ()
  416.   "Move forward to next point where something is amiss with the structure."
  417.   (interactive)
  418.   (push-mark)
  419.   (sgml-note-change-at (point))        ; Prune the parse tree
  420.   (sgml-parse-to (point))
  421.   (let ((sgml-throw-on-warning 'trouble))
  422.     (or (catch sgml-throw-on-warning
  423.       (sgml-parse-until-end-of nil t))
  424.     (message "Ok"))))
  425.  
  426.  
  427.  
  428. ;;;; SGML mode: information display
  429.  
  430. (defun sgml-list-valid-tags ()
  431.   "Display a list of the contextually valid tags."
  432.   (interactive)
  433.   (sgml-parse-to-here)
  434.   (let ((model (sgml-element-model sgml-current-tree))
  435.     (smap-name (sgml-lookup-shortref-name
  436.             (sgml-dtd-shortmaps sgml-dtd-info)
  437.             sgml-current-shortmap)))
  438.     (with-output-to-temp-buffer "*Tags*"
  439.       (princ (format "Current element: %s  %s\n"
  440.              (sgml-element-name sgml-current-tree)
  441.              (if (sgml-eltype-defined
  442.               (sgml-element-eltype sgml-current-tree))
  443.              ""
  444.                "[UNDEFINED]")))
  445.       (princ (format "Element content: %s  %s\n"
  446.              (cond ((or (sgml-current-mixed-p) (eq model sgml-any))
  447.                 "mixed")
  448.                ((sgml-model-group-p model)
  449.                 "element")
  450.                (t
  451.                 model))
  452.              (if (eq model sgml-any)
  453.              "[ANY]" "")))
  454.       
  455.       (when smap-name
  456.     (princ (format "Current short reference map: %s\n" smap-name)))
  457.       
  458.       (cond ((sgml-final-p sgml-current-state)
  459.          (princ "Valid end-tags : ")
  460.          (loop for e in (sgml-current-list-of-endable-eltypes)
  461.            do (princ (sgml-end-tag-of e)) (princ " "))
  462.          (terpri))
  463.         (t
  464.          (princ "Current element can not end here\n")))
  465. ;;;      (let ((s (sgml-tree-shortmap sgml-current-tree)))
  466. ;;;    (when s
  467. ;;;      (princ (format "Current shortref map: %s\n" s))))
  468.       (princ "Valid start-tags\n")
  469.       (sgml-print-valid-tags "In current element:"
  470.                  sgml-current-tree sgml-current-state))))
  471.  
  472. (defun sgml-print-valid-tags (prompt tree state &optional exclude omitted-stag)
  473.   (if (not (sgml-model-group-p state))
  474.       (princ (format "%s (in %s)\n" prompt state))
  475.     (let* ((req (sgml-required-tokens state))
  476.        (elems (nconc req
  477.              (delq sgml-pcdata-token
  478.                    (sgml-optional-tokens state))))
  479.        (in (sgml-tree-includes tree))
  480.        (ex (append exclude (sgml-tree-excludes tree))))
  481.       ;; Modify for exceptions
  482.       (while in
  483.     (unless (memq (car in) elems)
  484.       (setq elems (nconc elems (list (car in)))))
  485.     (setq in (cdr in)))
  486.       (while ex
  487.     (setq elems (delq (car ex) elems))
  488.     (setq ex (cdr ex)))
  489.       ;; 
  490.       (setq elems (sort elems (function string-lessp)))
  491.       (sgml-print-list-of-tags prompt elems)
  492.       ;; Check for omissable start-tags
  493.       (when (and req (null (cdr req)))
  494.     ;; *** Assumes tokens are eltypes
  495.     (let ((el (sgml-fake-open-element tree (car req))))
  496.       (when (sgml-element-stag-optional el)
  497.         (sgml-print-valid-tags
  498.          (format "If omitting %s:" (sgml-start-tag-of el))
  499.          el
  500.          (sgml-element-model el)
  501.          (append exclude elems)
  502.          'omitted-stag))))
  503.       ;; Check for omissable end-tag
  504.       (when (and (not omitted-stag)
  505.          (sgml-final-p state)
  506.          (sgml-element-etag-optional tree))
  507.     (sgml-print-valid-tags
  508.      (format "If omitting %s:" (sgml-end-tag-of tree))
  509.      (sgml-element-parent tree)
  510.      (sgml-element-pstate tree)
  511.      (append exclude elems))))))
  512.  
  513. (defun sgml-print-list-of-tags (prompt list)
  514.   (when list
  515.     (princ prompt)
  516.     (let ((col (length prompt))
  517.       (w   (1- (frame-width))))
  518.       (loop for e in list
  519.         as str = (sgml-start-tag-of e)
  520.         do
  521.         (setq col (+ col (length str) 2))
  522.         (cond ((>= col w)
  523.            (setq col (+ (length str) 2))
  524.            (terpri)))
  525.         (princ "  ")
  526.         (princ str))
  527.       (terpri))))
  528.  
  529. (defun sgml-show-context (&optional element)
  530.   "Display where the cursor is in the element hierarchy."
  531.   (interactive)
  532.   (let* ((el (or element (sgml-last-element)))
  533.      (model (sgml-element-model el)))
  534.     (sgml-message "%s %s" 
  535.           (cond
  536.            ((and (null element)    ; Don't trust sgml-markup-type if
  537.                     ; explicit element is given as argument
  538.              sgml-markup-type))
  539.            ((sgml-element-mixed el)
  540.             "#PCDATA")
  541.            ((not (sgml-model-group-p model))
  542.             model)
  543.            (t ""))
  544.           (if (eq el sgml-top-tree)
  545.               "in empty context"
  546.             (sgml-element-context-string el)))))
  547.  
  548. (defun sgml-what-element ()
  549.   "Display what element is under the cursor."
  550.   (interactive)
  551.   (let* ((pos (point))
  552.      (nobol (eq (point) sgml-rs-ignore-pos))
  553.      (sref (sgml-deref-shortmap sgml-current-shortmap nobol))
  554.      (el nil))
  555.     (goto-char pos)
  556.     (setq el (sgml-find-element-of pos))
  557.     (assert (not (null el)))
  558.     (message "%s %s"
  559.          (cond ((eq el sgml-top-tree)
  560.             "outside document element")
  561.            ((< (point) (sgml-element-stag-end el))
  562.             "start-tag")
  563.            ((>= (point) (sgml-element-etag-start el))
  564.             "end-tag")
  565.            (sref
  566.             "shortref")
  567.            (t
  568.             "content"))
  569.          (sgml-element-context-string el))))
  570.  
  571. ;;;; SGML mode: keyboard inserting
  572.  
  573. (defun sgml-insert-tag (tag &optional silent no-nl-after)
  574.   "Insert a tag, reading tag name in minibuffer with completion.
  575. If the variable sgml-balanced-tag-edit is t, also inserts the
  576. corresponding end tag. If sgml-leave-point-after-insert is t, the point
  577. is left after the inserted tag(s), unless the element has som required
  578. content.  If sgml-leave-point-after-insert is nil the point is left
  579. after the first tag inserted."
  580.   (interactive 
  581.    (list
  582.     (completing-read "Tag: " (sgml-completion-table) nil t "<" )))
  583.   (sgml-find-context-of (point))
  584.   (assert (null sgml-markup-type))
  585.   ;; Fix white-space before tag
  586.   (unless (sgml-element-data-p (sgml-parse-to-here))
  587.     (skip-chars-backward " \t")
  588.     (cond ((bolp)
  589.        (if (looking-at "^\\s-*$")
  590.            (fixup-whitespace)))
  591.       (t
  592.        (insert "\n"))))
  593.   (tempo-process-and-insert-string tag)
  594.   (sgml-indent-line)  
  595.   (unless no-nl-after
  596.     (save-excursion
  597.       (unless (sgml-element-data-p (sgml-parse-to-here))
  598.     (unless (eolp)
  599.       (save-excursion (insert "\n"))))))
  600.   (or silent (sgml-show-context)))
  601.  
  602. (defvar sgml-new-attribute-list-function
  603.   (function sgml-default-asl))
  604.  
  605. (defun sgml-insert-element (name &optional after silent)
  606.   "Reads element name from minibuffer and inserts start and end tags."
  607.   (interactive (list (sgml-read-element-name "Element: ")
  608.              sgml-leave-point-after-insert))
  609.   (let (newpos                ; position to leave cursor at
  610.     element                ; inserted element
  611.     (sgml-show-warnings nil))
  612.     (when (and name (not (equal name "")))
  613.       (sgml-insert-tag (sgml-start-tag-of name) 'silent)
  614.       (forward-char -1)
  615.       (setq element (sgml-find-element-of (point)))
  616.       (sgml-insert-attributes (funcall sgml-new-attribute-list-function
  617.                        element)
  618.                   (sgml-element-attlist element))
  619.       (forward-char 1)
  620.       (when (not (sgml-element-empty element))
  621.     (when (and sgml-auto-insert-required-elements
  622.            (sgml-model-group-p sgml-current-state))
  623.       (let (tem)
  624.         (while (and (setq tem (sgml-required-tokens sgml-current-state))
  625.             (null (cdr tem)))
  626.           (setq tem (sgml-insert-element (car tem) t t))
  627.           (setq newpos (or newpos tem))
  628.           (sgml-parse-to-here))
  629.         (when tem            ; more than one req elem
  630.           (insert "\n")
  631.           (when sgml-insert-missing-element-comment
  632.         (insert (format "<!-- one of %s -->" tem))
  633.         (sgml-indent-line nil element)))))
  634.     (setq newpos (or newpos (point)))
  635.     (when sgml-insert-end-tag-on-new-line
  636.       (insert "\n"))
  637.     (sgml-insert-tag (sgml-end-tag-of name) 'silent)
  638.     (unless after
  639.       (goto-char newpos))
  640.     (unless silent (sgml-show-context)))
  641.       newpos)))
  642.  
  643. (defun sgml-default-asl (element)
  644.   (loop for attdecl in (sgml-element-attlist element)
  645.     when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl)
  646.                     'required)
  647.     collect
  648.     (sgml-make-attspec
  649.      (sgml-attdecl-name attdecl)
  650.      (sgml-read-attribute-value attdecl nil))))
  651.  
  652. (defun sgml-tag-region (element start end)
  653.   "Reads element name from minibuffer and inserts start and end tags."
  654.   (interactive
  655.    (list
  656.     (save-excursion (goto-char (region-beginning))
  657.             (sgml-read-element-name "Tag region with element: "))
  658.     (region-beginning)
  659.     (region-end)))
  660.   (save-excursion
  661.     (when (and element (not (equal element "")))
  662.       (goto-char end)
  663.       (tempo-process-and-insert-string (sgml-end-tag-of element))
  664.       (goto-char start)
  665.       (sgml-insert-tag (sgml-start-tag-of element)))))
  666.  
  667. (defun sgml-insert-attributes (avl attlist)
  668.   "Insert the attributes with values AVL and declarations ATTLIST.
  669. AVL should be a assoc list mapping symbols to strings."
  670.   (let (name val dcl def)
  671.     (loop for attspec in attlist do
  672.       (setq name (sgml-attspec-name attspec)
  673.         val (cdr-safe (sgml-lookup-attspec name avl))
  674.         dcl (sgml-attdecl-declared-value attspec)
  675.         def (sgml-attdecl-default-value attspec))
  676.       (unless val            ; no value given
  677.         ;; Supply the default value if a value is needed
  678.         (cond ((sgml-default-value-type-p 'required def)
  679.            (setq val ""))
  680.           ((and (not (or sgml-omittag sgml-shorttag))
  681.             (consp def))
  682.            (setq val (sgml-default-value-attval def)))))
  683.       (cond 
  684.        ((null val))            ; Ignore
  685.        ;; Ignore attributes with default value
  686.        ((and (consp def)        
  687.          (eq sgml-minimize-attributes 'max)
  688.          (or sgml-omittag sgml-shorttag)
  689.          (equal val (sgml-default-value-attval def))))
  690.        ;; No attribute name for token groups
  691.        ((and sgml-minimize-attributes sgml-shorttag
  692.          (member (sgml-general-case val)
  693.              (sgml-declared-value-token-group dcl)))
  694.         (tempo-process-and-insert-string (concat " " val)))
  695.        (t
  696.         (tempo-process-and-insert-string (concat " " name "="))
  697.         (insert (sgml-quote-attribute-value val)))))
  698.     (when auto-fill-function
  699.       (funcall auto-fill-function))))
  700.  
  701.  
  702. (defun sgml-quote-attribute-value (value)
  703.   "Add quotes to the string VALUE unless minimization is on."
  704.   (let ((quote ""))
  705.     (cond ((and (not sgml-always-quote-attributes)
  706.             sgml-shorttag
  707.             (string-match "\\`[.A-Za-z0-9---]+\\'" value))
  708.            ) ; no need to quote
  709.           ((not (string-match "\"" value)) ; can use "" quotes
  710.            (setq quote "\""))
  711.           (t            ; use '' quotes
  712.            (setq quote "'")))
  713.     (concat quote value quote)))
  714.  
  715. (defun sgml-completion-table (&optional avoid-tags-in-cdata)
  716.   (sgml-parse-to-here)
  717.   (when sgml-markup-type
  718.     (error "No tags allowed"))
  719.   (cond ((or (sgml-model-group-p sgml-current-state)
  720.          (eq sgml-current-state sgml-any))
  721.      (append
  722.       (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x)))
  723.           (sgml-current-list-of-endable-eltypes))
  724.       (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x)))
  725.           (sgml-current-list-of-valid-eltypes))))
  726.     (t
  727.      (sgml-message "%s" sgml-current-state)
  728.      nil)))
  729.  
  730. (defun sgml-element-endable-p ()
  731.   (sgml-parse-to-here)
  732.   (and (not (eq sgml-current-tree sgml-top-tree))
  733.        (sgml-final-p sgml-current-state)))
  734.  
  735. (defun sgml-insert-end-tag ()
  736.   "Insert end-tag for the current open element."
  737.   (interactive "*")
  738.   (sgml-parse-to-here)
  739.   (cond
  740.    ((eq sgml-current-tree sgml-top-tree)
  741.     (sgml-error "No open element"))
  742.    ((not (sgml-final-p sgml-current-state))
  743.     (sgml-error "Can`t end element here"))
  744.    (t
  745.     (when (and sgml-indent-step
  746.            (not (sgml-element-data-p sgml-current-tree)))
  747.       (delete-horizontal-space)
  748.       (unless (bolp)
  749.     (insert "\n")))
  750.     (when (prog1 (bolp)
  751.         (tempo-process-and-insert-string
  752.           (if (eq t (sgml-element-net-enabled sgml-current-tree))
  753.           "/"
  754.         ;; wing change: If there is more than one endable
  755.         ;; tag, we probably want the outermost one rather
  756.         ;; than the innermost one.  Thus, we end a </ul>
  757.         ;; even when a </li> is possible.
  758.         (sgml-end-tag-of
  759.          (car (last (sgml-current-list-of-endable-eltypes)))))))
  760.       (sgml-indent-line)))))
  761.  
  762. (defun sgml-insert-start-tag (name asl attlist &optional net)
  763.   (tempo-process-and-insert-string (concat "<" name))
  764.   (sgml-insert-attributes asl attlist)
  765.   (insert (if net "/" ">")))
  766.  
  767. (defun sgml-change-start-tag (element asl)
  768.   (let ((name (sgml-element-gi element))
  769.     (attlist (sgml-element-attlist element)))
  770.     (assert (sgml-bpos-p (sgml-element-stag-epos element)))
  771.     (goto-char (sgml-element-start element))
  772.     (delete-char (sgml-element-stag-len element))
  773.     (sgml-insert-start-tag name asl attlist
  774.                (eq t (sgml-element-net-enabled element)))))
  775.  
  776. (defun sgml-read-attribute-value (attdecl curvalue)
  777.   "Return the attribute value read from user.
  778. ATTDECL is the attribute declaration for the attribute to read.
  779. CURVALUE is nil or a string that will be used as default value."
  780.   (assert attdecl)
  781.   (let* ((name (sgml-attdecl-name attdecl))
  782.      (dv (sgml-attdecl-declared-value attdecl))
  783.      (tokens (sgml-declared-value-token-group dv))
  784.      (notations (sgml-declared-value-notation dv))
  785.      (type (cond (tokens "token")
  786.              (notations "notation")
  787.              (t (symbol-name dv))))
  788.      (prompt
  789.       (format "Value for %s (%s%s): "
  790.           name type
  791.           (if curvalue
  792.               (format " Default: %s" curvalue)
  793.             "")))
  794.      value)
  795.     (setq value 
  796.       (if (or tokens notations)
  797.           (completing-read prompt
  798.                    (mapcar 'list (or tokens notations))
  799.                    nil t)
  800.         (read-string prompt)))
  801.     (if (and curvalue (equal value ""))
  802.     curvalue value)))
  803.  
  804. (defun sgml-non-fixed-attributes (attlist)
  805.   (loop for attdecl in attlist
  806.     unless (sgml-default-value-type-p 'fixed 
  807.                       (sgml-attdecl-default-value attdecl))
  808.     collect attdecl))
  809.  
  810. (defun sgml-insert-attribute (name value)
  811.   "Read attribute name and value from minibuffer and insert attribute spec."
  812.   (interactive
  813.    (let* ((el (sgml-find-attribute-element))
  814.       (name
  815.        (completing-read
  816.         "Attribute name: "
  817.         (mapcar (function (lambda (a) (list (sgml-attdecl-name a))))
  818.             (sgml-non-fixed-attributes (sgml-element-attlist el)))
  819.         nil t)))
  820.      (list name
  821.        (sgml-read-attribute-value
  822.         (sgml-lookup-attdecl name (sgml-element-attlist el))
  823.         (sgml-element-attval el name)))))
  824.   ;; Body
  825.   (assert (stringp name))
  826.   (assert (or (null value) (stringp value)))
  827.   (let* ((el (sgml-find-attribute-element))
  828.      (asl (cons (sgml-make-attspec name value)
  829.             (sgml-element-attribute-specification-list el)))
  830.      (in-tag (< (point) (sgml-element-stag-end el))))
  831.     (sgml-change-start-tag el asl)
  832.     (when in-tag (forward-char -1))))
  833.  
  834. (defun sgml-split-element ()
  835.   "Split the current element at point.
  836. If repeated, the containing element will be split before the beginning
  837. of then current element."
  838.   (interactive "*")
  839.   (setq sgml-split-level
  840.     (if (eq this-command last-command)
  841.         (1+ sgml-split-level)
  842.       0))
  843.   (let ((u (sgml-find-context-of (point)))
  844.     (start (point-marker)))
  845.     (loop repeat sgml-split-level do
  846.       (goto-char (sgml-element-start u))
  847.       (setq u (sgml-element-parent u)))
  848.     ;; Verify that a new element can be started
  849.     (unless (and (sgml-element-pstate u) ; in case of top element
  850.          (sgml-get-move (sgml-element-pstate u)
  851.                 (sgml-element-name u)))
  852.       
  853.       (sgml-error "The %s element can't be split"
  854.           (sgml-element-name u)))
  855.     ;; Do the split
  856.     (sgml-insert-end-tag)
  857.     (sgml-insert-tag (sgml-start-tag-of u) 'silent)
  858.     (skip-chars-forward " \t\n")
  859.     (sgml-indent-line)
  860.     (when (> sgml-split-level 0)
  861.       (goto-char start))
  862.     (or (eq sgml-top-tree
  863.         (setq u (sgml-element-parent u)))
  864.     (sgml-message
  865.      "Repeat the command to split the containing %s element"
  866.      (sgml-element-name u)))))
  867.  
  868. ;;; David Megginson's custom menus for keys
  869.  
  870. (defun sgml-custom-dtd (doctype)
  871.   "Insert a DTD declaration from the sgml-custom-dtd alist."
  872.   (interactive
  873.    (list (completing-read "Insert DTD: " sgml-custom-dtd nil t)))
  874.   (let ((entry (assoc doctype sgml-custom-dtd)))
  875.     (sgml-doctype-insert (second entry) (cddr entry))))
  876.  
  877. (defun sgml-custom-markup (markup)
  878.   "Insert markup from the sgml-custom-markup alist."
  879.   (interactive
  880.    (list (completing-read "Insert Markup: " sgml-custom-markup nil t)))
  881.   (sgml-insert-markup (cadr (assoc markup sgml-custom-markup))))
  882.  
  883.  
  884. ;;;; SGML mode: Menu inserting
  885.  
  886. (defun sgml-tags-menu (event)
  887.   "Pop up a menu with valid tags and insert the choosen tag.
  888. If the variable sgml-balanced-tag-edit is t, also inserts the
  889. corresponding end tag. If sgml-leave-point-after-insert is t, the point
  890. is left after the inserted tag(s), unless the element has som required
  891. content.  If sgml-leave-point-after-insert is nil the point is left
  892. after the first tag inserted."
  893.   (interactive "*e")
  894.   (let ((end (sgml-mouse-region)))
  895.     (sgml-parse-to-here)
  896.     (cond
  897.      ((eq sgml-markup-type 'start-tag)
  898.       (sgml-attrib-menu event))
  899.      (t
  900.       (let ((what
  901.          (sgml-menu-ask event (if (or end sgml-balanced-tag-edit)
  902.                   'element 'tags))))
  903.     (cond
  904.      ((null what))
  905.      (end
  906.       (sgml-tag-region what (point) end))
  907.      (sgml-balanced-tag-edit
  908.       (sgml-insert-element what))
  909.      (t
  910.       (sgml-insert-tag what))))))))
  911.  
  912. (defun sgml-element-menu (event)
  913.   "Pop up a menu with valid elements and insert choice.
  914. If sgml-leave-point-after-insert is nil the point is left after the first 
  915. tag inserted."
  916.   (interactive "*e")
  917.   (let ((what (sgml-menu-ask event 'element)))
  918.     (and what (sgml-insert-element what))))
  919.  
  920. (defun sgml-start-tag-menu (event)
  921.   "Pop up a menu with valid start-tags and insert choice."
  922.   (interactive "*e")
  923.   (let ((what (sgml-menu-ask event 'start-tag)))
  924.     (and what (sgml-insert-tag what))))
  925.  
  926. (defun sgml-end-tag-menu (event)
  927.   "Pop up a menu with valid end-tags and insert choice."
  928.   (interactive "*e")
  929.   (let ((what (sgml-menu-ask event 'end-tag)))
  930.     (and what (sgml-insert-tag what))))
  931.  
  932. (defun sgml-tag-region-menu (event)
  933.   "Pop up a menu with valid elements and tag current region with the choice."
  934.   (interactive "*e")
  935.   (let ((what (sgml-menu-ask event 'element)))
  936.     (and what (sgml-tag-region what
  937.                    (region-beginning)
  938.                    (region-end)))))
  939.  
  940. (defun sgml-menu-ask (event type)
  941.   (sgml-parse-to-here)
  942.   (let (tab
  943.     (title (capitalize (symbol-name type))))
  944.     (cond
  945.      (sgml-markup-type)
  946.      ((eq type 'element)
  947.       (setq tab
  948.         (mapcar (function symbol-name)
  949.             (sgml-current-list-of-valid-eltypes))))
  950.      (t
  951.       (unless (eq type 'start-tag)
  952.     (setq tab
  953.           (mapcar (function sgml-end-tag-of)
  954.               (sgml-current-list-of-endable-eltypes))))
  955.       (unless (eq type 'end-tag)
  956.     (setq tab
  957.           (nconc tab
  958.              (mapcar (function sgml-start-tag-of)
  959.                  (sgml-current-list-of-valid-eltypes)))))))
  960.     (or tab
  961.     (error "No valid %s at this point" type))
  962.     (or
  963.      (sgml-popup-menu event
  964.               title
  965.               (mapcar (function (lambda (x) (cons x x)))
  966.                   tab))
  967.      (message nil))))
  968.  
  969. (defun sgml-entities-menu (event)
  970.   (interactive "*e")
  971.   (sgml-need-dtd)
  972.   (let ((menu
  973.      (mapcar (function (lambda (x) (cons x x)))
  974.          (sort (sgml-map-entities (function sgml-entity-name)
  975.                       (sgml-dtd-entities sgml-dtd-info)
  976.                       t)
  977.                (function string-lessp))))
  978.     choice)
  979.     (unless menu
  980.       (error "No entities defined"))
  981.     (setq choice (sgml-popup-menu event "Entities" menu))
  982.     (when choice
  983.       (insert "&" choice ";"))))
  984.  
  985. (defun sgml-doctype-insert (doctype vars)
  986.   "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS.
  987. VARS should be a list of variables and values.
  988. For backward compatibility a single string instead of a variable is 
  989. assigned to sgml-default-dtd-file.
  990. All variables are made buffer local and are also added to the
  991. buffers local variables list."
  992.   (when doctype
  993.     (unless (bolp)
  994.       (insert "\n"))
  995.     (unless (eolp)
  996.       (insert "\n")
  997.       (forward-char -1))
  998.     (sgml-insert-markup doctype))
  999.   (while vars
  1000.     (cond ((stringp (car vars))
  1001.        (sgml-set-local-variable 'sgml-default-dtd-file (car vars))
  1002.        (setq vars (cdr vars)))
  1003.       ((car vars)            ; Avoid nil
  1004.        (sgml-set-local-variable (car vars) (cadr vars))
  1005.        (setq vars (cddr vars)))))
  1006.   (setq sgml-top-tree nil))
  1007.  
  1008. (defun sgml-attrib-menu (event)
  1009.   "Pop up a menu of the attributes of the current element
  1010. \(or the element whith start-tag before point)."
  1011.   (interactive "e")
  1012.     (let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element))))
  1013.       (sgml-popup-multi-menu event "Attributes" menu)))
  1014.  
  1015. (defun sgml-make-attrib-menu (el)
  1016.   (let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el))))
  1017.     (or attlist
  1018.     (error "No non-fixed attributes for element"))
  1019.     (loop for attdecl in attlist
  1020.       for name = (sgml-attdecl-name attdecl)
  1021.       for defval = (sgml-attdecl-default-value attdecl)
  1022.       for tokens = (or (sgml-declared-value-token-group
  1023.                 (sgml-attdecl-declared-value attdecl))
  1024.                (sgml-declared-value-notation
  1025.                 (sgml-attdecl-declared-value attdecl)))
  1026.       collect
  1027.       (cons
  1028.        (sgml-attdecl-name attdecl)
  1029.        (nconc
  1030.         (if tokens
  1031.         (loop for val in tokens collect
  1032.               (list val
  1033.                 (list 'sgml-insert-attribute name val)))
  1034.           (list
  1035.            (list "Set attribute value"
  1036.              (list 'sgml-insert-attribute
  1037.                (sgml-attdecl-name attdecl) 
  1038.                (list 'sgml-read-attribute-value
  1039.                  (list 'quote attdecl)
  1040.                  (sgml-element-attval el name))))))
  1041.         (if (sgml-default-value-type-p 'required defval)
  1042.         nil
  1043.           (list "--"
  1044.             (list (if (sgml-default-value-type-p nil defval)
  1045.                   (format "Default: %s"
  1046.                       (sgml-default-value-attval defval))
  1047.                 "#IMPLIED")
  1048.               (list 'sgml-insert-attribute name nil))))))))
  1049.   )
  1050.  
  1051. ;;;; SGML mode: Fill 
  1052.  
  1053. (defun sgml-fill-element (element)
  1054.   "Fill bigest enclosing element with mixed content.
  1055. If current element has pure element content, recursively fill the
  1056. subelements."
  1057.   (interactive (list (sgml-find-element-of (point))))
  1058.   ;;
  1059.   (message "Filling...")
  1060.   (when (sgml-element-mixed element)
  1061.     ;; Find bigest enclosing element with mixed content
  1062.     (while (sgml-element-mixed (sgml-element-parent element))
  1063.       (setq element (sgml-element-parent element))))
  1064.   ;; 
  1065.   (sgml-do-fill element)
  1066.   (sgml-message "Done"))
  1067.  
  1068. (defun sgml-do-fill (element)
  1069.   (when sgml-debug
  1070.     (goto-char (sgml-element-start element))
  1071.     (sit-for 0))
  1072.   (save-excursion
  1073.     (cond
  1074.      ((sgml-element-mixed element)
  1075.       (let (last-pos
  1076.         (c (sgml-element-content element))
  1077.         (agenda nil))        ; regions to fill later
  1078.     (goto-char (sgml-element-stag-end element))
  1079.     (when (eolp) (forward-char 1))
  1080.     (setq last-pos (point))
  1081.     (while c
  1082.       (cond
  1083.        ((sgml-element-mixed c))
  1084.        (t
  1085.         ;; Put region before element on agenda.  Can't fill it now
  1086.         ;; that would mangel the parse tree that is being traversed.
  1087.         (push (cons last-pos (sgml-element-start c))
  1088.           agenda)
  1089.         (goto-char (sgml-element-start c))
  1090.         (sgml-do-fill c)
  1091.         ;; Fill may change parse tree, get a fresh
  1092.         (setq c (sgml-find-element-of (point)))
  1093.         (setq last-pos (sgml-element-end c))))
  1094.       (setq c (sgml-element-next c)))
  1095.     ;; Fill the last region in content of element,
  1096.     ;; but get a fresh parse tree, if it has change due to other fills.
  1097.     (sgml-fill-region last-pos
  1098.               (sgml-element-etag-start
  1099.                (sgml-find-element-of
  1100.                 (sgml-element-start element))))
  1101.     (while agenda
  1102.       (sgml-fill-region (caar agenda) (cdar agenda))
  1103.       (setq agenda (cdr agenda)))))
  1104.      (t
  1105.       ;; If element is not mixed, fill subelements recursively
  1106.       (let ((c (sgml-element-content element)))
  1107.     (while c
  1108.       (goto-char (sgml-element-start c))
  1109.       (sgml-do-fill c)
  1110.       (setq c (sgml-element-next (sgml-find-element-of (point))))))))))
  1111.  
  1112. (defun sgml-fill-region (start end)
  1113.   (sgml-message "Filling...")
  1114.   (save-excursion
  1115.     (goto-char end)
  1116.     (skip-chars-backward " \t\n")
  1117.     (while (progn (beginning-of-line 1)
  1118.           (< start (point)))
  1119.       (delete-horizontal-space)
  1120.       (delete-char -1)
  1121.       (insert " "))
  1122.     (end-of-line 1)
  1123.     (let (give-up prev-column opoint)
  1124.       (while (and (not give-up) (> (current-column) fill-column))
  1125.     (setq prev-column (current-column))
  1126.     (setq opoint (point))
  1127.     (move-to-column (1+ fill-column))
  1128.     (skip-chars-backward "^ \t\n")
  1129.     (if (bolp)
  1130.         (re-search-forward "[ \t]" opoint t))
  1131.     (setq opoint (point))
  1132.     (skip-chars-backward " \t")
  1133.     (if (bolp)
  1134.         (setq give-up t)
  1135.     (delete-region (point) opoint)
  1136.     (newline)
  1137.     (sgml-indent-line)
  1138.     (end-of-line 1)
  1139.     (setq give-up (>= (current-column) prev-column)))))))
  1140.  
  1141. ;;;; SGML mode: Attribute editing
  1142.  
  1143. (defvar sgml-start-attributes nil)
  1144. (defvar sgml-main-buffer nil)
  1145. (defvar sgml-attlist nil)
  1146.  
  1147. (defun sgml-edit-attributes ()
  1148.   "Edit attributes of current element.
  1149. Editing is done in a separate window."
  1150.   (interactive)
  1151.   (let ((element (sgml-find-attribute-element)))
  1152.     (unless (sgml-bpos-p (sgml-element-stag-epos element))
  1153.       (error "Element's start-tag is not in the buffer"))
  1154.     (push-mark)
  1155.     (goto-char (sgml-element-start element))
  1156.     (let* ((start (point-marker))
  1157.        (asl (sgml-element-attribute-specification-list element))
  1158.        (cb (current-buffer))
  1159.        (quote sgml-always-quote-attributes))
  1160.        (switch-to-buffer-other-window
  1161.     (sgml-attribute-buffer element asl))
  1162.        (sgml-edit-attrib-mode)
  1163.        (make-local-variable 'sgml-attlist)
  1164.        (setq sgml-attlist (sgml-element-attlist element))
  1165.        (make-local-variable 'sgml-start-attributes)
  1166.        (setq sgml-start-attributes start)
  1167.        (make-local-variable 'sgml-always-quote-attributes)
  1168.        (setq sgml-always-quote-attributes quote)
  1169.        (make-local-variable 'sgml-main-buffer)
  1170.        (setq sgml-main-buffer cb))))
  1171.  
  1172. (defun sgml-attribute-buffer (element asl)
  1173.   (let ((bname "*Edit attributes*")
  1174.     (buf nil)
  1175.     (inhibit-read-only t))
  1176.     (save-excursion
  1177.       (when (setq buf (get-buffer bname))
  1178.     (kill-buffer buf))
  1179.       (setq buf (get-buffer-create bname))
  1180.       (set-buffer buf)
  1181.       (erase-buffer)
  1182.       (sgml-insert '(read-only t rear-nonsticky (read-only))
  1183.            "<%s  -- Edit values and finish with C-c C-c --\n"
  1184.            (sgml-element-name element))
  1185.       (loop
  1186.        for attr in (sgml-element-attlist element) do
  1187.        ;; Produce text like
  1188.        ;;  name = value
  1189.        ;;  -- declaration : default --
  1190.        (let* ((aname (sgml-attdecl-name attr))
  1191.           (dcl-value (sgml-attdecl-declared-value attr))
  1192.           (def-value (sgml-attdecl-default-value attr))
  1193.           (cur-value (sgml-lookup-attspec aname asl)))
  1194.      (sgml-insert            ; atribute name
  1195.       '(read-only t rear-nonsticky (read-only))
  1196.       " %s = " aname)
  1197.      (cond                ; attribute value
  1198.       ((sgml-default-value-type-p 'fixed def-value)
  1199.        (sgml-insert '(read-only t category sgml-fixed
  1200.                     rear-nonsticky (category))
  1201.             "#FIXED %s"
  1202.             (sgml-default-value-attval def-value)))
  1203.       ((and (null cur-value)
  1204.         (or (memq def-value '(implied conref current))
  1205.             (sgml-default-value-attval def-value)))
  1206.        (sgml-insert '(category sgml-default rear-nonsticky (category))
  1207.             "#DEFAULT"))
  1208.       ((not (null cur-value))
  1209.        (sgml-insert nil "%s" (sgml-attspec-attval cur-value))))
  1210.      (sgml-insert
  1211.       '(read-only 1)
  1212.       "\n\t-- %s: %s --\n"
  1213.       (cond ((sgml-declared-value-token-group dcl-value))
  1214.         ((sgml-declared-value-notation dcl-value)
  1215.          (format "NOTATION %s"
  1216.              (sgml-declared-value-notation dcl-value)))
  1217.         (t
  1218.          dcl-value))
  1219.       (cond ((sgml-default-value-attval def-value))
  1220.         (t
  1221.          (concat "#" (upcase (symbol-name def-value))))))))
  1222.       (sgml-insert '(read-only t) ">")
  1223.       (goto-char (point-min))
  1224.       (sgml-edit-attrib-next))
  1225.     buf))
  1226.  
  1227. (defvar sgml-edit-attrib-mode-map (make-sparse-keymap))
  1228. (define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish)
  1229. (define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default)
  1230. (define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-clear)
  1231.  
  1232. (define-key sgml-edit-attrib-mode-map "\C-a"  'sgml-edit-attrib-field-start)
  1233. (define-key sgml-edit-attrib-mode-map "\C-e"  'sgml-edit-attrib-field-end)
  1234. (define-key sgml-edit-attrib-mode-map "\t"  'sgml-edit-attrib-next)
  1235.  
  1236. (defun sgml-edit-attrib-mode ()
  1237.   "Major mode to edit attribute specification list.\\<sgml-edit-attrib-mode-map>
  1238. Use \\[sgml-edit-attrib-next] to move between input fields.  Use
  1239. \\[sgml-edit-attrib-default] to make an attribute have its default
  1240. value.  To abort edit kill buffer (\\[kill-buffer]) and remove window
  1241. (\\[delete-window]).  To finsh edit use \\[sgml-edit-attrib-finish].
  1242.  
  1243. \\{sgml-edit-attrib-mode-map}"
  1244.   (kill-all-local-variables)
  1245.   (setq mode-name "SGML edit attributes"
  1246.     major-mode 'sgml-edit-attrib-mode)
  1247.   (use-local-map sgml-edit-attrib-mode-map)
  1248.   (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook))
  1249.  
  1250. (defun sgml-edit-attrib-finish ()
  1251.   "Finish editing and insert attribute values in original buffer."
  1252.   (interactive)
  1253.   (let ((cb (current-buffer))
  1254.     (asl (sgml-edit-attrib-specification-list))
  1255.     ;; save buffer local variables
  1256.     (start sgml-start-attributes))
  1257.     (when (markerp start)
  1258.       (delete-windows-on cb)
  1259.       (switch-to-buffer (marker-buffer start))
  1260.       (kill-buffer cb)
  1261.       (goto-char start)
  1262.       (let ((element (sgml-find-element-of start)))
  1263.     ;; *** Should the it be verified that this element
  1264.     ;; is the one edited?
  1265.     (sgml-change-start-tag element asl)))))
  1266.  
  1267.  
  1268. (defun sgml-edit-attrib-specification-list ()
  1269.   (goto-char (point-min))
  1270.   (forward-line 1)
  1271.   (sgml-with-parser-syntax
  1272.    (let ((asl nil)
  1273.      (al sgml-attlist))
  1274.      (while (not (eq ?> (following-char)))
  1275.        (sgml-parse-s)
  1276.        (sgml-check-nametoken)        ; attribute name, should match head of al
  1277.        (forward-char 3)
  1278.        (unless (memq (get-text-property (point) 'category)
  1279.              '(sgml-default sgml-fixed))
  1280.      (push
  1281.       (sgml-make-attspec (sgml-attdecl-name (car al))
  1282.                  (sgml-extract-attribute-value
  1283.                   (sgml-attdecl-declared-value (car al))))
  1284.       asl))
  1285.        (while (progn (beginning-of-line 2)
  1286.              (or (eolp)
  1287.              (not (get-text-property (point) 'read-only)))))
  1288.  
  1289.        (forward-line 1)
  1290.        (setq al (cdr al)))
  1291.      asl)))
  1292.  
  1293.  
  1294. (defun sgml-extract-attribute-value (type)
  1295.   (save-excursion
  1296.     (save-restriction
  1297.       (narrow-to-region (point)
  1298.             (progn (sgml-edit-attrib-field-end)
  1299.                    (point)))
  1300.       (unless (eq type 'cdata)
  1301.     (subst-char-in-region (point-min) (point-max) ?\n ? )
  1302.     (goto-char (point-min))
  1303.     (delete-horizontal-space))
  1304.       (goto-char (point-min))
  1305.       (when (search-forward "\"" nil t)    ; don't allow both " and '
  1306.     (goto-char (point-min))
  1307.     (while (search-forward "'" nil t) ; replace ' with char ref
  1308.       (replace-match "'")))
  1309.       (buffer-string))))
  1310.  
  1311. (defun sgml-edit-attrib-default ()
  1312.   "Set current attribute value to default."
  1313.   (interactive)
  1314.   (sgml-edit-attrib-clear)
  1315.   (save-excursion
  1316.     (sgml-insert '(category sgml-default)
  1317.          "#DEFAULT")))
  1318.  
  1319. (defun sgml-edit-attrib-clear ()
  1320.   "Kill the value of current attribute."
  1321.   (interactive)
  1322.   (kill-region
  1323.    (progn (sgml-edit-attrib-field-start) (point))
  1324.    (progn (sgml-edit-attrib-field-end) (point))))
  1325.  
  1326. (defun sgml-edit-attrib-field-start ()
  1327.   "Go to the start of the attribute value field."
  1328.   (interactive)
  1329.   (let (start)
  1330.         (beginning-of-line 1)
  1331.     (while (not (eq t (get-text-property (point) 'read-only)))
  1332.       (beginning-of-line 0))
  1333.     (setq start (next-single-property-change (point) 'read-only))
  1334.     (unless start (error "No attribute value here"))
  1335.     (assert (number-or-marker-p start))
  1336.     (goto-char start)))
  1337.  
  1338. (defun sgml-edit-attrib-field-end ()
  1339.   "Go to the end of the attribute value field."
  1340.   (interactive)
  1341.   (sgml-edit-attrib-field-start)
  1342.   (let ((end (if (and (eolp)
  1343.               (get-text-property (1+ (point)) 'read-only))
  1344.          (point)
  1345.            (next-single-property-change (point) 'read-only))))
  1346.     (assert (number-or-marker-p end))
  1347.     (goto-char end)))
  1348.  
  1349. (defun sgml-edit-attrib-next ()
  1350.   "Move to next attribute value."
  1351.   (interactive)
  1352.   (or (search-forward-regexp "^ *[.A-Za-z0-9---]+ *= ?" nil t)
  1353.       (goto-char (point-min))))
  1354.  
  1355.  
  1356. ;;;; SGML mode: Hiding tags/attributes
  1357.  
  1358. (defconst sgml-tag-regexp
  1359.   "\\(</?>\\|</?[A-Za-z][---A-Za-z0-9.]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)>?\\)")
  1360.  
  1361. (defun sgml-operate-on-tags (action &optional attr-p)
  1362.   (let ((buffer-modified-p (buffer-modified-p))
  1363.     (inhibit-read-only t)
  1364.     (buffer-read-only nil)
  1365.     (before-change-function nil)
  1366.     (markup-index            ; match-data index in tag regexp
  1367.      (if attr-p 2 1))
  1368.     (tagcount            ; number tags to give them uniq
  1369.                     ; invisible properties
  1370.      1))
  1371.     (unwind-protect
  1372.     (save-excursion
  1373.       (goto-char (point-min))
  1374.       (while (re-search-forward sgml-tag-regexp nil t)
  1375.         (cond
  1376.          ((eq action 'hide)
  1377.           (let ((tag (downcase
  1378.               (buffer-substring-no-properties
  1379.                (1+ (match-beginning 0))
  1380.                (match-beginning 2)))))
  1381.         (if (or attr-p (not (member tag sgml-exposed-tags)))
  1382.             (add-text-properties
  1383.              (match-beginning markup-index) (match-end markup-index)
  1384.              (list 'invisible tagcount
  1385.                'rear-nonsticky '(invisible face))))))
  1386.          ((eq action 'show)        ; ignore markup-index
  1387.           (remove-text-properties (match-beginning 0) (match-end 0)
  1388.                       '(invisible nil)))
  1389.          (t (error "Invalid action: %s" action)))
  1390.         (incf tagcount)))
  1391.       (set-buffer-modified-p buffer-modified-p))))
  1392.  
  1393. (defun sgml-hide-tags ()
  1394.   "Hide all tags in buffer."
  1395.   (interactive)
  1396.   (sgml-operate-on-tags 'hide))
  1397.  
  1398. (defun sgml-show-tags ()
  1399.   "Show hidden tags in buffer."
  1400.   (interactive)
  1401.   (sgml-operate-on-tags 'show))
  1402.  
  1403. (defun sgml-hide-attributes ()
  1404.   "Hide all attribute specifications in the buffer."
  1405.   (interactive)
  1406.   (sgml-operate-on-tags 'hide 'attributes))
  1407.  
  1408. (defun sgml-show-attributes ()
  1409.   "Show all attribute specifications in the buffer."
  1410.   (interactive)
  1411.   (sgml-operate-on-tags 'show 'attributes))
  1412.  
  1413.  
  1414. ;;;; SGML mode: Normalize (and misc manipulations)
  1415.  
  1416. (defun sgml-expand-shortref-to-text (name)
  1417.   (let (before-change-function
  1418.     (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info))))
  1419.     (cond
  1420.      ((null entity) (sgml-error "Undefined entity %s" name))
  1421.      ((sgml-entity-data-p entity)
  1422.       (sgml-expand-shortref-to-entity name))
  1423.      (t
  1424.       (delete-region sgml-markup-start (point))
  1425.       (sgml-entity-insert-text entity)
  1426.       (setq sgml-goal (point-max))    ; May have changed size of buffer
  1427.       ;; now parse the entity text
  1428.       (setq sgml-rs-ignore-pos sgml-markup-start)
  1429.       (goto-char sgml-markup-start)))))
  1430.  
  1431. (defun sgml-expand-shortref-to-entity (name)
  1432.   (let ((end (point))
  1433.     (re-found nil)
  1434.     before-change-function)
  1435.     (goto-char sgml-markup-start)
  1436.     (setq re-found (search-forward "\n" end t))
  1437.     (delete-region sgml-markup-start end)       
  1438.     (insert "&" name (if re-found "\n" ";"))
  1439.     (setq sgml-goal (point-max))    ; May have changed size of buffer
  1440.     (goto-char (setq sgml-rs-ignore-pos sgml-markup-start))))
  1441.  
  1442. (defun sgml-expand-all-shortrefs (to-entity)
  1443.   "Expand all short references in the buffer.
  1444. Short references to text entities are expanded to the replacement text
  1445. of the entity other short references are expanded into general entity
  1446. references.  If argument, TO-ENTITY, is non-nil, or if called
  1447. interactive with numeric prefix argument, all short references are
  1448. replaced by generaly entity references."
  1449.   (interactive "*P")
  1450.   (sgml-reparse-buffer
  1451.    (if to-entity
  1452.        (function sgml-expand-shortref-to-entity)
  1453.      (function sgml-expand-shortref-to-text))))
  1454.  
  1455. (defun sgml-normalize (to-entity &optional element)
  1456.   "Normalize buffer by filling in omitted tags and expanding empty tags.
  1457. Argument TO-ENTITY controls how short references are expanded as with
  1458. `sgml-expand-all-shortrefs'.  An optional argument ELEMENT can be the
  1459. element to normalize insted of the whole buffer, if used no short
  1460. references will be expanded."
  1461.   (interactive "*P")
  1462.   (unless element
  1463.     (sgml-expand-all-shortrefs to-entity))
  1464.   (let ((only-one (not (null element))))
  1465.     (setq element (or element (sgml-top-element)))
  1466.     (goto-char (sgml-element-end element)) 
  1467.     (let ((before-change-function nil))
  1468.       (sgml-normalize-content element only-one)))
  1469.   (sgml-note-change-at (sgml-element-start element))
  1470.   (sgml-message "Done"))
  1471.  
  1472. (defun sgml-normalize-element ()
  1473.   (interactive "*")
  1474.   (sgml-normalize nil (sgml-find-element-of (point))))
  1475.  
  1476. (defun sgml-normalize-content (element only-first)
  1477.   "Normalize all elements in a content where ELEMENT is first element.
  1478. If sgml-normalize-trims is non-nil, trim off white space from ends of
  1479. elements with omitted end-tags."
  1480.   (let ((content nil))
  1481.     (while element            ; Build list of content elements
  1482.       (push element content)
  1483.       (setq element (if only-first
  1484.             nil
  1485.               (sgml-element-next element))))
  1486.     (while content
  1487.       (setq element (car content))
  1488.       ;; Progress report
  1489.       (sgml-lazy-message "Normalizing %d%% left"
  1490.              (/ (point) (/ (+ (point-max) 100) 100)))
  1491.       ;; Fix the end-tag
  1492.       (sgml-normalize-end-tag element)
  1493.       ;; Fix tags of content
  1494.       (sgml-normalize-content (sgml-tree-content element) nil)
  1495.       ;; Fix the start-tag
  1496.       (sgml-normalize-start-tag element)
  1497.       ;; Next content element
  1498.       (setq content (cdr content)))))
  1499.  
  1500. (defun sgml-normalize-start-tag (element)
  1501.   (when (sgml-bpos-p (sgml-element-stag-epos element))
  1502.     (goto-char (min (point) (sgml-element-start element)))
  1503.     (let ((name (sgml-element-gi element))
  1504.       (attlist (sgml-element-attlist element))
  1505.       (asl (sgml-element-attribute-specification-list element)))
  1506.       (save-excursion
  1507.     (assert (or (zerop (sgml-element-stag-len element))
  1508.             (= (point) (sgml-element-start element))))
  1509.     (delete-char (sgml-element-stag-len element))
  1510.     (sgml-insert-start-tag name asl attlist nil)))))
  1511.  
  1512. (defun sgml-normalize-end-tag (element)
  1513.   (unless (sgml-element-empty element)
  1514.     (when (sgml-bpos-p (sgml-element-etag-epos element))
  1515.       (goto-char (min (point) (sgml-element-etag-start element)))    
  1516.       (if (and (zerop (sgml-element-etag-len element))
  1517.            sgml-normalize-trims)
  1518.       (skip-chars-backward " \t\n\r"))
  1519.       (delete-char (sgml-tree-etag-len element))
  1520.       (save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element))))))
  1521.  
  1522.  
  1523. (defun sgml-make-character-reference (&optional invert)
  1524.   "Convert character after point into a character reference.
  1525. If called with a numeric argument, convert a character reference back
  1526. to a normal character.  If called from a program, set optional
  1527. argument INVERT to non-nil."
  1528.   (interactive "*P")
  1529.   (cond
  1530.    (invert
  1531.     (or (looking-at "&#\\([0-9]+\\)[;\n]?")
  1532.     (error "No character reference after point"))
  1533.     (let ((c (string-to-int (buffer-substring (match-beginning 1)
  1534.                           (match-end 1)))))
  1535.       (delete-region (match-beginning 0)
  1536.              (match-end 0))
  1537.       (insert c)))
  1538.    ;; Convert character to &#nn;
  1539.    (t
  1540.     (let ((c (following-char)))
  1541.       (delete-char 1)
  1542.       (insert (format "&#%d;" c))))))
  1543.  
  1544. (defun sgml-expand-entity-reference ()
  1545.   "Insert the text of the entity referenced at point."
  1546.   (interactive)
  1547.   (sgml-with-parser-syntax
  1548.    (setq sgml-markup-start (point))
  1549.    (sgml-check-delim "ERO")
  1550.    (let* ((ename (sgml-check-name t))
  1551.       (entity (sgml-lookup-entity ename
  1552.                       (sgml-dtd-entities
  1553.                        (sgml-pstate-dtd
  1554.                     sgml-buffer-parse-state)))))
  1555.      (unless entity
  1556.        (error "Undefined entity %s" ename))
  1557.      (or (sgml-parse-delim "REFC")
  1558.      (sgml-parse-RE))
  1559.      (delete-region sgml-markup-start (point))
  1560.      (sgml-entity-insert-text entity))))
  1561.  
  1562.  
  1563. ;;;; SGML mode: TAB completion
  1564.  
  1565. (defun sgml-complete ()
  1566.   "Complete the word/tag/entity before point.
  1567. If it is a tag (starts with < or </) complete with valid tags.
  1568. If it is an entity (starts with &) complete with declared entities.
  1569. If it is a markup declaration (starts with <!) complete with markup 
  1570. declaration names.
  1571. If it is something else complete with ispell-complete-word."
  1572.   (interactive "*")
  1573.   (let ((tab                ; The completion table
  1574.      nil)
  1575.     (pattern nil)
  1576.     (c nil)
  1577.     (here (point)))
  1578.     (skip-chars-backward "^ \n\t</!&%")
  1579.     (setq pattern (buffer-substring (point) here))
  1580.     (setq c (char-after (1- (point))))
  1581.     (cond
  1582.      ;; entitiy
  1583.      ((eq c ?&)
  1584.       (sgml-need-dtd)
  1585.       (setq tab
  1586.         (sgml-entity-completion-table
  1587.          (sgml-dtd-entities (sgml-pstate-dtd sgml-buffer-parse-state)))))
  1588.      ;; start-tag
  1589.      ((eq c ?<)
  1590.       (save-excursion
  1591.     (backward-char 1)
  1592.     (sgml-parse-to-here)
  1593.     (setq tab (sgml-eltype-completion-table
  1594.            (sgml-current-list-of-valid-eltypes)))))
  1595.      ;; end-tag
  1596.      ((eq c ?/)
  1597.       (save-excursion
  1598.     (backward-char 2)
  1599.     (sgml-parse-to-here)
  1600.     (setq tab (sgml-eltype-completion-table
  1601.            (sgml-current-list-of-endable-eltypes)))))
  1602.      ;; markup declaration
  1603.      ((eq c ?!)
  1604.       (setq tab sgml-markup-declaration-table))
  1605.      (t
  1606.       (goto-char here)
  1607.       (ispell-complete-word)))
  1608.     (when tab
  1609.       (let ((completion (try-completion pattern tab)))
  1610.     (cond ((null completion)
  1611.            (goto-char here)
  1612.            (message "Can't find completion for \"%s\"" pattern)
  1613.            (ding))
  1614.           ((eq completion t)
  1615.            (goto-char here)
  1616.            (message "[Complete]"))
  1617.           ((not (string= pattern completion))
  1618.            (delete-char (length pattern))
  1619.            (insert completion))
  1620.           (t
  1621.            (goto-char here)
  1622.            (message "Making completion list...")
  1623.            (let ((list (all-completions pattern tab)))
  1624.          (with-output-to-temp-buffer " *Completions*"
  1625.            (display-completion-list list)))
  1626.            (message "Making completion list...%s" "done")))))))
  1627.  
  1628.  
  1629. ;;;; SGML mode: Options menu
  1630.  
  1631. (defun sgml-file-options-menu (&optional event)
  1632.   (interactive "e")
  1633.   (sgml-options-menu event sgml-file-options))
  1634.  
  1635. (defun sgml-user-options-menu (&optional event)
  1636.   (interactive "e")
  1637.   (sgml-options-menu event sgml-user-options))
  1638.  
  1639. (defun sgml-options-menu (event vars)
  1640.   (let ((var
  1641.      (let ((maxlen 
  1642.         (loop for var in vars
  1643.               maximize (length (sgml-variable-description var)))))
  1644.        (sgml-popup-menu
  1645.         event "Options"
  1646.         (loop for var in vars
  1647.           for desc = (sgml-variable-description var)
  1648.           collect
  1649.           (cons
  1650.            (format "%s%s [%s]"
  1651.                desc
  1652.                (make-string (- maxlen (length desc)) ? )
  1653.                (sgml-option-value-indicator var))
  1654.            var))))))
  1655.     (when var
  1656.       (sgml-do-set-option var event))))
  1657.  
  1658. (defun sgml-do-set-option (var &optional event)
  1659.   (let ((type (sgml-variable-type var))
  1660.     (val (symbol-value var)))
  1661.     (cond
  1662.      ((eq 'toggle type)
  1663.       (message "%s set to %s" var (not val))
  1664.       (set var (not val)))
  1665.      ((eq 'string type)
  1666.       (describe-variable var)
  1667.       (setq val (read-string (concat (sgml-variable-description var) ": ")))
  1668.       (when (stringp val)
  1669.     (set var val)))
  1670.      ((consp type)
  1671.       (let ((val
  1672.          (sgml-popup-menu event
  1673.                   (sgml-variable-description var)
  1674.                   (loop for c in type collect
  1675.                     (cons
  1676.                      (if (consp c) (car c) (format "%s" c))
  1677.                      (if (consp c) (cdr c) c))))))
  1678.     (set var val)
  1679.     (message "%s set to %s" var val)))
  1680.      (t
  1681.       (describe-variable var)
  1682.       (setq val (read-string (concat (sgml-variable-description var)
  1683.                      " (sexp): ")))
  1684.       (when (stringp val)
  1685.     (set var (car (read-from-string val)))))))
  1686.   (force-mode-line-update))
  1687.  
  1688. (defun sgml-option-value-indicator (var)
  1689.   (let ((type (sgml-variable-type var))
  1690.     (val (symbol-value var)))
  1691.     (cond
  1692.      ((eq type 'toggle)
  1693.       (if val "Yes" "No"))
  1694.      ((eq type 'string)
  1695.       (if (stringp val)
  1696.       (substring val 0 4)
  1697.     "-"))
  1698.      ((and (atom type) val)
  1699.       "...")
  1700.      ((consp type)
  1701.       (or (car (rassq val type))
  1702.       val))
  1703.      (t
  1704.       "-"))))
  1705.  
  1706. ;;;; NEW
  1707.  
  1708. (defun sgml-trim-and-leave-element ()
  1709.   (interactive)
  1710.   (goto-char (sgml-element-etag-start (sgml-last-element)))
  1711.   (while (progn (forward-char -1)
  1712.         (looking-at "\\s-"))
  1713.     (delete-char 1))
  1714.   (sgml-up-element))
  1715.  
  1716.  
  1717. ;;; psgml-edit.el ends here
  1718.